;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
;;; Copyright © 2020 Maxime Devos <maxime.devos@student.kuleuven.be>
;;; This file is part of rehash.
;;;
;;; rehash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; rehash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with rehash.  If not, see <http://www.gnu.org/licenses/>.

;; FIXME: probably full of bugs, write many tests
;; FIXME: eventually leave the loop
(define-module (rehash fibers)
  #:use-module (rehash)
  #:use-module (rnrs base)
  #:use-module (fibers)
  #:use-module (fibers channels)
  #:use-module (fibers conditions)
  #:use-module (fibers operations)
  #:use-module (fibers timers)
  #:use-module ((fibers internal)
                #:select (resume-on-readable-fd
                          resume-on-writable-fd
                          suspend-current-fiber))
  #:use-module (srfi srfi-9)
  #:use-module ((srfi srfi-60)
                #:select (bitwise-ior bitwise-and))
  #:use-module ((rnrs bytevectors)
                #:select (bytevector-copy!))
  #:use-module (system foreign)
  #:use-module (ice-9 match)
  #:use-module (ice-9 suspendable-ports)
  #:export (init-fibers-scheduler!
            start-fibers-scheduler!
            do-gnunet-stuff))

;; These five dfintions are
;; adapted from guile-gnunet
(define gnunet-ok            1)
(define gnunet-system-error -1)
(define gnunet-yes           1)
(define gnunet-no            0)
(define (int->bool x)
  (cond ((= x gnunet-ok) #t)
        ((= x gnunet-no) #f)
        (else (assert (and #f "bad GNUnet boolean")))))

(define (time-absolute->fiber-time absolute)
  ;; absolute is in microseconds since the
  ;; unix epoch
  absolute)
(define (operation-sleep-until absolute)
  (trace "will sleep until")
  (assert (< absolute (expt 2 64)))
  (trace absolute)
  (wrap-operation
   (timer-operation absolute)
   (lambda _ '*beep*beep*)))

(define debugging? #t)
(define (trace . args)
  (when debugging?
    (display args)
    (newline)))

;; Replace GNUnet's scheduler with Fibers.
;; Warning: GNUnet is singly-threaded.

(define %GNUNET_Scheduler_Driver
  '(* ;; closure
    * ;; add a task to be run
    * ;; delete a task to be run
    * ;; set time for a wake-up
    ))

(define ET_NONE 0) ; no event (perhaps a time-out)
(define ET_IN  1) ; reading
(define ET_OUT 2) ; writing

(define-record-type task-data
  (make-task-data task/pointer network-handle/pointer file-handle/pointer
                  event-type fdi no-reading-cvar no-writing-cvar)
  ;; All pointers are invalid when %del has been called,
  ;; in which case pointers are set to #f
  task-data?
  (task/pointer task-data-pointer set-task-data-pointer!)
  ;; GNUnet network socket, maybe NULL
  (network-handle/pointer task-data-network-handle/pointer
                          set-task-data-network-handle/pointer!)
  ;; GNUnet file handle, maybe NULL
  (file-handle/pointer task-data-file-handle/pointer
                       set-task-data-file-handle/pointer!)
  ;; event type to wait for
  (event-type task-data-event-type)
  ;; gnunet FdInfo pointer to inform what
  ;; the waited socket can be used for.
  ;; Only use fro
  (fdi task-data-fdi set-task-data-fdi!)
  ;; condition variables to stop the ‘polling‘ fibers
  ;; These are the only fields that may be used
  ;; concurrently.
  (no-reading-cvar task-data-no-reading-cvar)
  (no-writing-cvar task-data-no-writing-cvar))

(define (stop-polling! task-data)
  "Stop polling for reading / writing"
  (signal-condition! (task-data-no-reading-cvar task-data))
  (signal-condition! (task-data-no-writing-cvar task-data)))

(define (invalidate-pointers! task-data)
  "Replace all pointers in @var{task-data} with #f"
  (set-task-data-pointer! task-data #f)
  (set-task-data-network-handle/pointer! task-data #f)
  (set-task-data-file-handle/pointer! task-data #f)
  (set-task-data-fdi! task-data #f))

(define (task-invalidated? task-data)
  (not (task-data-pointer task-data)))

(define c:task-ready!
  (delayed-ffi "GNUNET_SCHEDULER_task_ready"
               void
               '(* *)))
(define (gnunet-mark-ready! task-data)
  "Tell the GNUnet scheduler a task can continue"
  (c:task-ready! (task-data-pointer task-data)
                 (task-data-fdi task-data)))

(define-record-type fibers-driver-data
  (make-fibers-driver-data tasks notifications *beep*beep*)
  fibers-driver-data?
  ;; Tasks to run under conditions.
  ;; A list of #(task/pointer file-descriptor-info absolute-time).
  ;; absolute-time: when to wake up from sleeping (or #f)
  ;; Todo use a heap maybe
  ;; TODO check set_wakeup interpretation
  ;; The list may be mutated in-place.
  (tasks tasks-todo set-tasks-todo!)
  ;; Used by start-fd-waiter! to notify fiber-loop
  ;; of usable descriptors (a channel)
  (notifications notifications)
  ;; When to wake up even if no events happened
  (*beep*beep* beep-beep set-beep-beep!))

(define %GNUNET_Scheduler_FdInfo
  `(;; GNUnet network socket, maybe NULL
    *
    ;; GNUnet file handle, maybe NULL
    *
    ;; event type
    ,int
    ;; File descriptor
    ,int))

(define (fdi-event-type/pointer fdinfo/pointer)
  (bytevector->pointer
   (pointer->bytevector fdinfo/pointer
                        (sizeof %GNUNET_Scheduler_FdInfo))
   (sizeof '(* *))))

(define (read-waiter-thunk fiber-data task-data fd interrupt-cvar)
  ;; XXX use interrupt-cvar to kill fiber early
  (lambda ()
    (suspend-current-fiber
     (lambda (fiber)
       (trace "waiting for reading")
       (resume-on-readable-fd fd fiber)))
    (if (signal-condition! interrupt-cvar)
        (begin
          (trace "reading became possible! (or we got a EINTR)")
          ;; task-data may be invalidated by now, but that's ok,
          ;; because fiber-loop will just dispose of invalidated
          ;; tasks.
          (put-message (notifications fiber-data)
                       `(fd-update ,task-data ,ET_IN)))
        (trace "waiting for reading was interrupted!"))))

(define (write-waiter-thunk fiber-data task-data fd interrupt-cvar)
  ;; Same comments as in read-waiter-thunk apply
  (lambda ()
    (suspend-current-fiber
     (lambda (fiber)
       (trace "waiting for writing...")
       (resume-on-writable-fd fd fiber)))
    (if (signal-condition! interrupt-cvar)
        (begin (trace "writing became possible! (or we got a EINTR)")
               (put-message (notifications fiber-data)
                            `(fd-update ,task-data ,ET_OUT)))
        (trace "waiting for writing was interrupted!"))))

(define %add
  (procedure->pointer
   int
   (lambda (fiber-data/pointer task/pointer fdi/pointer)
     (trace "%add entered")
     (let* ((fiber-data (pointer->scm fiber-data/pointer))
            (file-descriptor-info
             (parse-c-struct fdi/pointer %GNUNET_Scheduler_FdInfo))
            (desired-event-types
             (list-ref file-descriptor-info 2))
            (fd (list-ref file-descriptor-info 3))
            (interrupt-read-wait-cvar (make-condition))
            (interrupt-write-wait-cvar (make-condition))
            (task-data
             (make-task-data task/pointer
                             ;; network
                             (list-ref file-descriptor-info 0)
                             ;; file
                             (list-ref file-descriptor-info 1)
                             ;; event type to wait for
                             desired-event-types
                             ;; file descriptor info
                             ;; (e.g. for tellig the GNUnet
                             ;; scheduler some IO is possible)
                             fdi/pointer
                             interrupt-read-wait-cvar
                             interrupt-write-wait-cvar)))
       (set-tasks-todo! fiber-data (cons task-data (tasks-todo fiber-data)))
       (if (= (bitwise-and desired-event-types ET_IN) ET_IN)
           (spawn-fiber (read-waiter-thunk fiber-data task-data fd
                                           interrupt-read-wait-cvar)))
       (if (= (bitwise-and desired-event-types ET_OUT) ET_OUT)
           (spawn-fiber (write-waiter-thunk fiber-data task-data fd
                                            interrupt-write-wait-cvar)))
       (assert (and (< 0 desired-event-types)
                    (< desired-event-types 4))))
     (trace "leaving %add")
     ;; GNUNET_OK
     1)
   '(* * *)))

;; FIXME
(define %del
  (procedure->pointer
   int
   (lambda (fiber-data/pointer task/pointer)
     "The GNUnet scheduler is telling us to forget about a task"
     (define fiber-data (pointer->scm fiber-data/pointer))
     (define ret gnunet-system-error)
     (assert (pointer? task/pointer))
     (let ((still-alive
            ;; TODO maybe use a hash map
            ;; TODO can filter! visit an element
            ;;  multiple times?
            (filter!
             (lambda (task-data)
               (let ((that-pointer
                      (task-data-pointer task-data)))
                 ;; Verify only interesting
                 ;; things are kept in the todo list.
                 ;; (Some polling fibers may
                 ;; still have a reference to
                 ;; a deleted task, but that's ok)
                 ;; TODO may fit
                 (assert (pointer? that-pointer))
                 (if (equal? task/pointer that-pointer)
                     ;; invalidate-pointers!: no use after free
                     ;; stop-polling!: stop wasting resources
                     ;; FIXME actually enable this.
                     ;; Temporarily disabled for debugging.
                     (begin (if #f (stop-polling! task-data))
                            (invalidate-pointers! task-data)
                            (set! ret gnunet-ok)
                            #f)
                     #t)))
             (tasks-todo fiber-data))))
       (set-tasks-todo! fiber-data still-alive))
     ret)
   '(* *)))

(define %set-wakeup
  ;; only called from within the GNUnet thread
  (procedure->pointer
   void
   (lambda (fiber-data/pointer time-absolute)
     (set-beep-beep! (pointer->scm fiber-data/pointer)
                     (if (= time-absolute (- (expt 2 64) 1))
                         ;; Special value meaning
                         ;; waiting forever
                         #f
                         time-absolute))
     *unspecified*)
   ;; TODO can we equate uint64_t = struct { uit64_t name; }?
   `(* ,uint64)))

(define (make-driver cls/pointer add/c del/c set-wakeup/c)
  ;; TODO is it assumed this can be deallocated with GNUNET_free?
  (make-c-struct
   %GNUNET_Scheduler_Driver
   (list cls/pointer add/c del/c set-wakeup/c)))

(define (driver-for-fibers fiber-data)
  (make-driver (scm->pointer fiber-data)
               %add
               %del
               %set-wakeup))

(define c:driver-init
  (delayed-ffi "GNUNET_SCHEDULER_driver_init"
               '*
               '(*)))

(define c:do-work
  (delayed-ffi "GNUNET_SCHEDULER_do_work"
               int
               '(*)))
(define (gnunet-do-work *scheduler*)
  (display "poke")
  (let ((ans (c:do-work *scheduler*)))
    (display "poked")
    (display ans)
    (assert (or (= ans gnunet-ok)
                (= ans gnunet-no)))
    (int->bool ans)))

(define *scheduler* #f)
(define *driver* #f)
(define *fiber-data* #f)
(define *scheduler-active?* #f)

(define (init-fibers-scheduler!)
  "Use Guile-Fibers as the GNUnet scheduler!

No-op if the scheduler is already set.
Concurrent initialisation is thread-unsafe.
All tasks submitted to the scheduler will
be serially executed in a single thread,
but not necessarily an OS-level thread.

Remember to call this and start-fibers-scheduler!
from within a Fibers-scheduler."
  (if (not *scheduler*)
      (begin
        (set! *fiber-data* (make-fibers-driver-data '() (make-channel) 0))
        (set! *driver* (driver-for-fibers *fiber-data*))
        ;; TODO maybe don't install signal handlers
        (set! *scheduler* (c:driver-init *driver*)))))

;; TODO driver_done

(define (start-fibers-scheduler!)
  ""
  (assert (not *scheduler-active?*))
  (spawn-fiber (lambda () (fiber-loop #f)))
  (set! *scheduler-active?* #t))

;; never written to
(define broken-channel (make-channel))

(define (add-task-data-fdi-flags! td event-type)
  "Mark some event types as ready.
Only to be called from the GNUnet thread."
  (let* ((p (fdi-event-type/pointer (task-data-fdi td)))
         (et-old (car (parse-c-struct p `(,int))))
         (et-new (bitwise-ior et-old event-type))
         ;; FIXME less indirection
         (et-new/pointer
          (make-c-struct `(,int) (list et-new))))
    (trace et-new/pointer)
    (trace p)
    (bytevector-copy! (pointer->bytevector et-new/pointer
                                           (sizeof int))
                      0
                      (pointer->bytevector p (sizeof int))
                      0
                      (sizeof int))))

(define (fiber-loop more-todo)
  "more-todo: #t if there are more tasks ready to be run"
  ;; See if some task has become
  ;; runnable
  (trace "entering fiber-loop")
  (define *some-action-possible* '())

  (let loop ()
    (define get-msg-op
      (get-operation (notifications *fiber-data*)))
    (define timeout-op
      (let ((*beep*beep* (beep-beep *fiber-data*)))
        (trace 'sleep-to *beep*beep*)
        (trace 'more-todo? more-todo)
        ;; If there are more tasks ready to run,
        ;; don't sleep!
        (cond (more-todo
               (wrap-operation
                (sleep-operation 0)
                (lambda _ 'nothing)))
              ;; A time-out is set,
              ;; some limited-duration
              ;; waiting is acceptable
              (*beep*beep*
               (operation-sleep-until *beep*beep*))
              ;; No time-outs, no ready tasks,
              ;; just wait for change in
              ;; file descriptor status,
              ;; or new tasks to do
              ;; in GNUnet context
              (#t
               (wrap-operation
                (get-operation broken-channel)
                (lambda ()
                  (assert (and 0 "huh?"))))))))
    (define msg-or-timeout
      (choice-operation get-msg-op timeout-op))
    (trace "let's see what happened")
    (trace msg-or-timeout)
    (define msg (perform-operation msg-or-timeout))
    (trace "will do this:")
    (trace msg)
    (match msg
      ;; no changes, exit the loop
      ('nothing #f)
      ;; GNUnet says we're lazy and we should
      ;; do something instead.
      ('*beep*beep* #f)
      ;; perform something in the GNUnet thread
      (`(do-gnunet ,thunk)
       (thunk)
       ;; the thunk may have called %add (indirectly)
       (set! more-todo #t)
       (loop))
      ;; something became possible!
      (`(fd-update ,task-data ,event-type)
       (if (task-invalidated? task-data)
           ;; ... but we have no use for it anymore!
           (begin
             (trace "nom nom race")
             (loop))
           ;; ... and it's still useful for GNUnet!
           (begin
             (trace "yay!")
             (set! more-todo #t)
             (set! *some-action-possible*
               (cons (cons task-data event-type) *some-action-possible*))
             (loop))))
      (_ (assert (and #f "bad message!")))))
  ;; Update information on what to wait upon
  (for-each (lambda (td-et)
              (trace "poking" td-et)
              (let ((task-data (car td-et))
                    (event-type (cdr td-et)))
                ;; TODO are these events
                ;; waited for in the wild
                ;; in GNUnet code?
                (assert (< event-type 4))
                (assert (< (task-data-event-type task-data) 4))
                ;; not waiting for these anymore
                (when (not (= 0 event-type))
                  (add-task-data-fdi-flags! task-data event-type)
                  (stop-polling! task-data)
                  (gnunet-mark-ready! task-data))))
            *some-action-possible*)

  ;; Run a few ready tasks!
  (trace "let's do some stuff")
  (let ((more-work (gnunet-do-work *scheduler*)))
    (trace "gnunet-do-work said:")
    (trace more-work)
    ;; TODO evenually break the loop
    (fiber-loop more-work)))

(define (do-gnunet-stuff thunk)
  "Do stuff on the GNUnet thread"
  (trace "inserting stuff todo")
  (put-message (notifications *fiber-data*)
               `(do-gnunet ,thunk))
  (trace "stuff has been accepted!"))

